home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / class.c < prev    next >
C/C++ Source or Header  |  1993-06-25  |  13KB  |  481 lines
  1. /* ******************************************************************** */
  2. /*  class.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* classes                                                    */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: class.c,v 2.1 1993/01/17 17:25:21 pab Exp pab $
  9.  *
  10.  * $Log: class.c,v $
  11.  * Revision 2.1  1993/01/17  17:25:21  pab
  12.  * 17 Jan 1993 The next generation...
  13.  *
  14.  * Revision 1.19  1992/11/25  17:07:01  pab
  15.  * Table changes, local_count->lispobject
  16.  *
  17.  * Revision 1.17  1992/08/06  18:09:48  pab
  18.  * more reflective operations
  19.  * q
  20.  *
  21.  * Revision 1.16  1992/06/12  00:03:02  pab
  22.  * added more reflective-type hacks
  23.  *
  24.  * Revision 1.15  1992/06/09  13:58:35  pab
  25.  * added set class , etc
  26.  *
  27.  * Revision 1.14  1992/05/26  12:28:40  pab
  28.  * fixed for moving modules (xxx_template)
  29.  *
  30.  * Revision 1.13  1992/05/19  11:15:58  pab
  31.  * exported alloc class, instance
  32.  *
  33.  * Revision 1.12  1992/04/26  21:00:15  pab
  34.  * alloc_int fixes
  35.  *
  36.  * Revision 1.11  1992/03/14  14:33:48  pab
  37.  * side efects return values
  38.  *
  39.  * Revision 1.10  1992/02/27  15:46:57  pab
  40.  * bytecode + error changes
  41.  *
  42.  * Revision 1.9  1992/01/29  13:39:10  pab
  43.  * Fixed gc bug
  44.  *
  45.  * Revision 1.8  1992/01/22  13:29:49  pab
  46.  * Fixed GC bug
  47.  *
  48.  * Revision 1.7  1992/01/17  22:28:06  pab
  49.  * Removed defstruct + defclass 'cos
  50.  * no one used them
  51.  *
  52.  * Revision 1.6  1992/01/09  22:28:46  pab
  53.  * Fixed for low tag ints
  54.  *
  55.  * Revision 1.5  1992/01/05  22:47:57  pab
  56.  * Minor bug fixes, plus BSD version
  57.  *
  58.  * Revision 1.4  1991/12/22  15:13:56  pab
  59.  * Xmas revision
  60.  *
  61.  * Revision 1.3  1991/11/15  13:44:31  pab
  62.  * copyalloc rev 0.01
  63.  *
  64.  * Revision 1.2  1991/09/11  12:07:05  pab
  65.  * 11/9/91 First Alpha release of modified system
  66.  *
  67.  * Revision 1.1  1991/08/12  16:49:30  pab
  68.  * Initial revision
  69.  *
  70.  * Revision 1.10  1991/06/17  19:05:23  pab
  71.  * altered set_assoc to eval properly.
  72.  *
  73.  * Revision 1.8  1991/02/13  18:18:53  kjp
  74.  * Pass.
  75.  *
  76.  */
  77.  
  78. #define KJPDBG(x)
  79. #define INOUT(x)
  80. #define CLASSBUG(x) /* fprintf(stderr,"CLASSBUG:");x;fflush(stderr) */
  81.  
  82. /*
  83.  * Change Log:
  84.  *   Version 1, June 1989
  85.  *   Version N ( N >> 1 ), November 1989
  86.  *   Mostly killed. Pab. Dec 92.
  87.  */
  88.  
  89. #include <stdio.h>
  90. #include "defs.h"
  91. #include "structs.h"
  92.  
  93. #include "funcalls.h"
  94.  
  95. #include "global.h"
  96. #include "error.h"
  97.  
  98. #include "class.h"
  99. #include "vectors.h"
  100. #include "table.h"
  101. #include "bootstrap.h"
  102. #include "slots.h"
  103. #include "ngenerics.h"
  104. #include "modules.h"
  105. #include "modboot.h"
  106. #include "garbage.h"
  107. #include "calls.h"
  108.  
  109. static LispObject reader_template(LispObject *);
  110. static LispObject writer_template(LispObject *);
  111.  
  112. #define CLASSES_ENTRIES 34
  113. MODULE Module_classes;
  114. static LispObject classes_module; /* Utter hack, Module_x no longer useful */
  115. LispObject Module_classes_values[CLASSES_ENTRIES];
  116.  
  117. static LispObject generic_initialize;
  118. static LispObject generic_allocate;
  119.  
  120. EUFUN_1(Fn_class_of,x)
  121. {
  122.   return classof(x);
  123. }
  124. EUFUN_CLOSE
  125.  
  126. EUFUN_2(Fn_set_class,x,cl)
  127. {
  128.   return lval_classof(x)=cl;
  129. }
  130. EUFUN_CLOSE
  131.  
  132. EUFUN_1(Fn_classp,x)
  133. {
  134.   return (typeof(x)==TYPE_CLASS ? lisptrue : nil);
  135. }
  136. EUFUN_CLOSE
  137.  
  138. EUFUN_2(Gf_make_instance,x,lst)
  139. {
  140.   LispObject proto;
  141.   
  142.   proto=generic_apply_2(stacktop,generic_allocate,x,lst);
  143.   return generic_apply_2(stacktop,generic_initialize,proto,ARG_1(stackbase));
  144. }
  145. EUFUN_CLOSE
  146.  
  147. EUFUN_2(Fn_subclassp,c1,c2)
  148. {
  149.   LispObject prec;
  150.   
  151.   if (c1 == c2) return(c1); /* Used to say lisptrue which is wrong */
  152.   
  153.   prec=c1->CLASS.precedence;
  154.   
  155.   while (prec!=nil)
  156.     {
  157.       if (CAR(prec)==c2)
  158.     return c1;
  159.       else
  160.     prec=CDR(prec);
  161.     }
  162.   
  163.   return(nil);
  164. }
  165. EUFUN_CLOSE
  166.  
  167. LispObject search_keylist(LispObject *stacktop,LispObject list,LispObject key)
  168. {
  169.   int i=0;
  170.   LispObject ptr;
  171.  
  172.   if (list != nil && !is_cons(list))
  173.     CallError(stacktop,"invalid key list",list,NONCONTINUABLE);
  174.   
  175.   ptr=list;
  176.   while (ptr!=nil)
  177.     { i++;
  178.       ptr=CDR(ptr);
  179.     }
  180.  
  181.   if (i%2 != 0)
  182.     CallError(stacktop,"unbalanced initlist",list,NONCONTINUABLE);
  183.  
  184.  
  185.   while(list != nil) {
  186.     LispObject lkey = CAR(list);
  187.     LispObject lval = CAR(CDR(list));
  188.     
  189.     if (key == lkey) return(lval);
  190.  
  191.     list = CDR(CDR(list));
  192.   }
  193.  
  194.   return(unbound);
  195. }
  196.  
  197.  
  198. EUFUN_1(Fn_allocate_object,class)
  199. {
  200.   LispObject ans;
  201.  
  202.   ans=allocate_instance(stacktop,class);
  203.  
  204.   return ans;
  205. }
  206. EUFUN_CLOSE
  207.  
  208. EUFUN_2(Fn_set_type,x,n)
  209. {
  210.   lval_typeof(x)=intval(n);
  211.   return x;
  212. }
  213. EUFUN_CLOSE
  214.  
  215. EUFUN_2(Fn_slot_ref,o,n)
  216. {
  217.   return slotref(o,intval(n));
  218. }
  219. EUFUN_CLOSE
  220.  
  221. EUFUN_3(Fn_set_slot_ref,o,n,v)
  222. {
  223.   return slotrefupdate(o,intval(n),v);
  224. }
  225. EUFUN_CLOSE
  226.  
  227.  
  228. static EUFUN_1(Fn_slot_0_ref,o) { return slotref(o,0); }EUFUN_CLOSE
  229. static EUFUN_1(Fn_slot_1_ref,o) { return slotref(o,1); }EUFUN_CLOSE
  230. static EUFUN_1(Fn_slot_2_ref,o) { return slotref(o,2); }EUFUN_CLOSE
  231. static EUFUN_1(Fn_slot_3_ref,o) { return slotref(o,3); }EUFUN_CLOSE
  232. static EUFUN_1(Fn_slot_4_ref,o) { return slotref(o,4); }EUFUN_CLOSE
  233. static EUFUN_1(Fn_slot_5_ref,o) { return slotref(o,5); }EUFUN_CLOSE
  234. static EUFUN_1(Fn_slot_6_ref,o) { return slotref(o,6); }EUFUN_CLOSE
  235. static EUFUN_1(Fn_slot_7_ref,o) { return slotref(o,7); }EUFUN_CLOSE
  236. static EUFUN_1(Fn_slot_8_ref,o) { return slotref(o,8); }EUFUN_CLOSE
  237. static EUFUN_1(Fn_slot_9_ref,o) { return slotref(o,9); }EUFUN_CLOSE
  238.  
  239. static EUFUN_2(Fn_set_slot_0,o,v) { return slotrefupdate(o,0,v); } EUFUN_CLOSE
  240. static EUFUN_2(Fn_set_slot_1,o,v) { return slotrefupdate(o,1,v); } EUFUN_CLOSE
  241. static EUFUN_2(Fn_set_slot_2,o,v) { return slotrefupdate(o,2,v); } EUFUN_CLOSE
  242. static EUFUN_2(Fn_set_slot_3,o,v) { return slotrefupdate(o,3,v); } EUFUN_CLOSE
  243. static EUFUN_2(Fn_set_slot_4,o,v) { return slotrefupdate(o,4,v); } EUFUN_CLOSE
  244. static EUFUN_2(Fn_set_slot_5,o,v) { return slotrefupdate(o,5,v); } EUFUN_CLOSE
  245. static EUFUN_2(Fn_set_slot_6,o,v) { return slotrefupdate(o,6,v); } EUFUN_CLOSE
  246. static EUFUN_2(Fn_set_slot_7,o,v) { return slotrefupdate(o,7,v); } EUFUN_CLOSE
  247. static EUFUN_2(Fn_set_slot_8,o,v) { return slotrefupdate(o,8,v); } EUFUN_CLOSE
  248. static EUFUN_2(Fn_set_slot_9,o,v) { return slotrefupdate(o,9,v); } EUFUN_CLOSE
  249.  
  250. /* Slot accessors with a type check */
  251. EUFUN_2(Fn_make_structure_reader,class,n)
  252. {
  253.   LispObject reader;
  254.  
  255.   reader=make_anonymous_module_env_function_2(stacktop, classes_module,
  256.                           reader_template,1,
  257.                           lisptrue, class,
  258.                           lisptrue,n);
  259.   
  260.   return reader;
  261. }
  262. EUFUN_CLOSE
  263.  
  264. EUFUN_2(Fn_make_structure_writer,class,n)
  265. {
  266.   LispObject writer;
  267.  
  268.   writer=make_anonymous_module_env_function_2(stacktop, classes_module,
  269.                           writer_template,2,
  270.                           lisptrue, class,
  271.                           lisptrue, n);
  272.   
  273.   return writer;
  274. }
  275. EUFUN_CLOSE
  276.  
  277. static EUFUN_2(reader_template, env, obj)
  278. {
  279.   LispObject class, n;
  280.   /* Envs get switched by make_env_fn */
  281.   n=env->ENV.value;
  282.   class=env->ENV.next->ENV.value;
  283.  
  284.   if (EUCALL_2(Fn_subclassp,classof(obj),class)==nil)
  285.     {
  286.       LispObject xx;
  287.       STACK_TMP(class); STACK_TMP(n);
  288.       xx=EUCALL_2(Fn_cons,obj,nil);
  289.       UNSTACK_TMP(n);
  290.       xx=EUCALL_2(Fn_cons,n,xx);
  291.       UNSTACK_TMP(class);
  292.       xx=EUCALL_2(Fn_cons,class,xx);
  293.       CallError(stacktop,"wrong class of object for reader",xx,NONCONTINUABLE);
  294.     }
  295.  
  296.   return(slotref(obj,intval(n)));
  297. }
  298. EUFUN_CLOSE
  299.  
  300. static EUFUN_3(writer_template, env, obj, val)
  301. {
  302.   LispObject class, n;
  303.   n=env->ENV.value;
  304.   class=env->ENV.next->ENV.value;
  305.  
  306.   if (EUCALL_2(Fn_subclassp,classof(obj),class)==nil)
  307.     {
  308.       LispObject xx;
  309.       STACK_TMP(class); STACK_TMP(n); 
  310.       xx=EUCALL_2(Fn_cons,obj,nil);
  311.       UNSTACK_TMP(n);
  312.       xx=EUCALL_2(Fn_cons,n,xx);
  313.       UNSTACK_TMP(class);
  314.       xx=EUCALL_2(Fn_cons,class,xx);
  315.       CallError(stacktop,"wrong class of object for writer",xx,NONCONTINUABLE);
  316.     }
  317.  
  318.   return(slotrefupdate(obj,intval(n),val));
  319. }
  320. EUFUN_CLOSE
  321.  
  322. static EUFUN_2(Fn_initialize_local_slots,obj,lst)
  323. {
  324.   LispObject slots,inits,initarg,initfunc,val;
  325.   int n=0;
  326.  
  327.   slots=classof(obj)->CLASS.local_slot_list;
  328.   
  329.   while (slots!=nil)
  330.     {    
  331.       if (CAR(slots)!=nil)
  332.     {
  333.       val=unbound;
  334.       initarg=init_slot_initarg(CAR(slots));
  335.       if (initarg!=unbound)
  336.         {
  337.           inits=lst;
  338.           while (inits!=nil)
  339.         {
  340.           if (CAR(inits)==initarg)
  341.             {
  342.               val=CAR(CDR(inits));
  343.               break;
  344.             }     
  345.           inits=CDR(CDR(inits));
  346.         }
  347.           /* initarg not found --- continue */
  348.         }
  349.       
  350.       if (val==unbound && (initfunc=init_slot_initfunction(CAR(slots)))!=unbound)
  351.         {
  352.           STACK_TMP(slots);
  353.           val=EUCALL_2(Fn_apply,initfunc,nil);
  354.           UNSTACK_TMP(slots);
  355.           obj=ARG_0(stackbase);
  356.           lst=ARG_1(stackbase);
  357.         }
  358.       slotref(obj,n)=val;
  359.     }
  360.       slots=CDR(slots);
  361.       n++;
  362.     }
  363.   return obj;
  364. }
  365. EUFUN_CLOSE
  366.  
  367. /* *************************************************************** */
  368. /* Initialisation of this module (should be separate...)           */
  369. /* *************************************************************** */
  370.  
  371. /* Class name module stuff... */
  372.  
  373. #define CLASS_NAMES_ENTRIES 25 /* Too many */
  374. MODULE Module_class_names;
  375. LispObject Module_class_names_values[CLASS_NAMES_ENTRIES];
  376.  
  377. void register_class_names(LispObject *stacktop,LispObject c)
  378. {
  379.   LispObject sub;
  380.  
  381.   make_module_entry_using_symbol(stacktop,c->CLASS.name,c);
  382.  
  383.   sub = c->CLASS.subclasses;
  384.  
  385.   while (sub != nil) {
  386.     STACK_TMP(CDR(sub));
  387.     register_class_names(stacktop,CAR(sub));
  388.     UNSTACK_TMP(sub);
  389.   }
  390. }
  391.  
  392. /* *************************************************************** */
  393. /* Initialisation of this module                                   */
  394. /* *************************************************************** */
  395.  
  396. #define SET_ASSOC(a,b) \
  397.   { LispObject tmp,tmp2; \
  398.     STACK_TMP(a); \
  399.     tmp2=b; \
  400.     UNSTACK_TMP(tmp); \
  401.     set_anon_associate(stacktop,tmp,tmp2); \
  402.   }
  403.  
  404. void initialise_classes(LispObject *stacktop)
  405. {
  406.  
  407.  
  408.   open_module(stacktop,
  409.           &Module_class_names,Module_class_names_values,
  410.           "class-names",CLASS_NAMES_ENTRIES);
  411.   initialize_boot_classes(stacktop);
  412.   close_module();
  413.  
  414.   /* Class operations */
  415.  
  416.  
  417.   open_module(stacktop,
  418.           &Module_classes,Module_classes_values,
  419.           "classes",CLASSES_ENTRIES);
  420.  
  421.   generic_initialize
  422.     = make_module_generic(stacktop,"initialize",2);
  423.   
  424.   generic_allocate
  425.     = make_module_generic(stacktop,"allocate",2);
  426.   
  427.   add_root(&generic_initialize);
  428.   add_root(&generic_allocate);
  429.  
  430.   /* Class object accessors... */
  431.  
  432.   (void) make_module_function(stacktop,"classp",Fn_classp,1);
  433.   (void) make_module_function(stacktop,"subclassp",Fn_subclassp,2);
  434.   (void) make_module_function(stacktop,"class-of",Fn_class_of,1);
  435.  
  436.   make_module_function(stacktop,"set-class-of",Fn_set_class,2);
  437.   make_module_function(stacktop,"set-type",Fn_set_type,2);
  438.   make_module_function(stacktop,"allocate-object",Fn_allocate_object,1);
  439.   make_module_function(stacktop,"primitive-slot-ref",Fn_slot_ref,2);
  440.   make_module_function(stacktop,"primitive-set-slot-ref",Fn_set_slot_ref,3);
  441.  
  442.   make_module_function(stacktop,"make",Gf_make_instance,-2);
  443.  
  444.   make_module_function(stacktop,"primitive-slot-ref-0",Fn_slot_0_ref,1);
  445.   make_module_function(stacktop,"primitive-slot-ref-1",Fn_slot_1_ref,1);
  446.   make_module_function(stacktop,"primitive-slot-ref-2",Fn_slot_2_ref,1);
  447.   make_module_function(stacktop,"primitive-slot-ref-3",Fn_slot_3_ref,1);
  448.   make_module_function(stacktop,"primitive-slot-ref-4",Fn_slot_4_ref,1);
  449.   make_module_function(stacktop,"primitive-slot-ref-5",Fn_slot_5_ref,1);
  450.   make_module_function(stacktop,"primitive-slot-ref-6",Fn_slot_6_ref,1);
  451.   make_module_function(stacktop,"primitive-slot-ref-7",Fn_slot_7_ref,1);
  452.   make_module_function(stacktop,"primitive-slot-ref-8",Fn_slot_8_ref,1);
  453.   make_module_function(stacktop,"primitive-slot-ref-9",Fn_slot_9_ref,1);
  454.  
  455.   make_module_function(stacktop,"primitive-set-slot-ref-0",Fn_set_slot_0,2);
  456.   make_module_function(stacktop,"primitive-set-slot-ref-1",Fn_set_slot_1,2);
  457.   make_module_function(stacktop,"primitive-set-slot-ref-2",Fn_set_slot_2,2);
  458.   make_module_function(stacktop,"primitive-set-slot-ref-3",Fn_set_slot_3,2);
  459.   make_module_function(stacktop,"primitive-set-slot-ref-4",Fn_set_slot_4,2);
  460.   make_module_function(stacktop,"primitive-set-slot-ref-5",Fn_set_slot_5,2);
  461.   make_module_function(stacktop,"primitive-set-slot-ref-6",Fn_set_slot_6,2);
  462.   make_module_function(stacktop,"primitive-set-slot-ref-7",Fn_set_slot_7,2);
  463.   make_module_function(stacktop,"primitive-set-slot-ref-8",Fn_set_slot_8,2);
  464.   make_module_function(stacktop,"primitive-set-slot-ref-9",Fn_set_slot_9,2);
  465.  
  466.   make_module_function(stacktop,"make-structure-reader", Fn_make_structure_reader,2);
  467.   make_module_function(stacktop,"make-structure-writer", Fn_make_structure_writer,2);
  468.  
  469.   make_module_function(stacktop,"initialize-local-slots", Fn_initialize_local_slots,2);
  470.   close_module();
  471.  
  472.   {
  473.     LispObject xx;
  474.     xx=get_symbol(stacktop,"classes");
  475.  
  476.     classes_module=get_module(stacktop,xx);
  477.     add_root(&classes_module);
  478.   }
  479. }
  480.  
  481.